home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / kcl.lha / c / toplevel.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  5KB  |  214 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     toplevel.c
  10.  
  11.     Top-Level Forms and Declarations
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. object Sdeclare;
  17. object Scompile, Sload, Seval;
  18. object Sprogn;
  19.  
  20. object siSvariable_documentation;
  21. object siSfunction_documentation;
  22.  
  23. object Swarn;
  24.  
  25. object siVinhibit_macro_special;
  26.  
  27. object Svalues, Stypep;
  28.  
  29. Fdefun(args)
  30. object args;
  31. {
  32.     object name;
  33.     object body, form;
  34.  
  35.     if (endp(args) || endp(MMcdr(args)))
  36.         FEtoo_few_argumentsF(args);
  37.     if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons)
  38.         FEerror("~S is an illegal lambda-list.", 1, MMcadr(args));
  39.     name = MMcar(args);
  40.     if (type_of(name) != t_symbol)
  41.         not_a_symbol(name);
  42.     if (name->s.s_sfdef != NOT_SPECIAL) {
  43.         if (name->s.s_mflag) {
  44.             if (symbol_value(siVinhibit_macro_special) != Cnil)
  45.                 name->s.s_sfdef = NOT_SPECIAL;
  46.         } else if (symbol_value(siVinhibit_macro_special) != Cnil)
  47.          FEerror("~S, a special form, cannot be redefined.", 1, name);
  48.     }
  49.     clear_compiler_properties(name);
  50.     if (name->s.s_hpack == lisp_package &&
  51.         name->s.s_gfdef != OBJNULL && initflag) {
  52.         vs_push(make_simple_string(
  53.             "~S is being redefined."));
  54.         ifuncall2(Swarn, vs_head, name);
  55.         vs_pop;
  56.     }
  57.     vs_base = vs_top;
  58.     if (lex_env[0] == Cnil && lex_env[1] == Cnil && lex_env[2] == Cnil) {
  59.         vs_push(MMcons(Slambda_block, args));
  60.     } else {
  61.         vs_push(MMcons(lex_env[2], args));
  62.         vs_base[0] = MMcons(lex_env[1], vs_base[0]);
  63.         vs_base[0] = MMcons(lex_env[0], vs_base[0]);
  64.         vs_base[0] = MMcons(Slambda_block_closure, vs_base[0]);
  65.     }
  66.     name->s.s_gfdef = vs_base[0];
  67.     name->s.s_mflag = FALSE;
  68.     vs_base[0] = name;
  69.     for (body = MMcddr(args);  !endp(body);  body = body->c.c_cdr) {
  70.         form = macro_expand(body->c.c_car);
  71.         if (type_of(form) == t_string) {
  72.             if (endp(body->c.c_cdr))
  73.                 break;
  74.             vs_push(form);
  75.             name->s.s_plist =
  76.             putf(name->s.s_plist,
  77.                  form,
  78.                  siSfunction_documentation);
  79.             vs_pop;
  80.             break;
  81.         }
  82.         if (type_of(form) != t_cons || form->c.c_car != Sdeclare)
  83.             break;
  84.     }
  85. }
  86.     
  87. siLAmake_special()
  88. {
  89.     check_arg(1);
  90.     check_type_symbol(&vs_base[0]);
  91.     if ((enum stype)vs_base[0]->s.s_stype == stp_constant)
  92.         FEerror("~S is a constant.", 1, vs_base[0]);
  93.     vs_base[0]->s.s_stype = (short)stp_special;
  94. }
  95.  
  96. siLAmake_constant()
  97. {
  98.     check_arg(2);
  99.     check_type_symbol(&vs_base[0]);
  100.     if ((enum stype)vs_base[0]->s.s_stype == stp_special)
  101.         FEerror(
  102.          "The argument ~S to DEFCONSTANT is a special variable.",
  103.          1, vs_base[0]);
  104.     vs_base[0]->s.s_stype = (short)stp_constant;
  105.     vs_base[0]->s.s_dbind = vs_base[1];
  106.     vs_pop;
  107. }
  108.  
  109. Feval_when(arg)
  110. object arg;
  111. {
  112.     object *base = vs_base;
  113.     object ss;
  114.     bool flag = FALSE;
  115.  
  116.     if(endp(arg))
  117.         FEtoo_few_argumentsF(arg);
  118.     for (ss = MMcar(arg);  !endp(ss);  ss = MMcdr(ss))
  119.         if(MMcar(ss) == Seval)
  120.             flag = TRUE;
  121.         else if(MMcar(ss) != Sload && MMcar(ss) != Scompile)
  122.          FEinvalid_form("~S is an undefined situation for EVAL-WHEN.",
  123.                 MMcar(ss));
  124.     if(flag) {
  125.         vs_push(make_cons(Sprogn, MMcdr(arg)));
  126.         eval(vs_head);
  127.     } else {
  128.         vs_base = base;
  129.         vs_top = base+1;
  130.         vs_base[0] = Cnil;
  131.     }
  132. }
  133.  
  134. Fdeclare(arg)
  135. object arg;
  136. {
  137.     FEerror("DECLARE appeared in an invalid position.", 0);
  138. }
  139.  
  140. Flocally(body)
  141. object body;
  142. {
  143.     object *oldlex = lex_env;
  144.     object x, ds, vs, v;
  145.  
  146.     lex_copy();
  147.     body = find_special(body, NULL, NULL);
  148.     vs_push(body);
  149.     Fprogn(body);
  150.     lex_env = oldlex;
  151. }
  152.  
  153. Fthe(args)
  154. object args;
  155. {
  156.     object *vs;
  157.  
  158.     if(endp(args) || endp(MMcdr(args)))
  159.         FEtoo_few_argumentsF(args);
  160.     if(!endp(MMcddr(args)))
  161.         FEtoo_many_argumentsF(args);
  162.     eval(MMcadr(args));
  163.     args = MMcar(args);
  164.     if (type_of(args) == t_cons && MMcar(args) == Svalues) {
  165.         vs = vs_base;
  166.         for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){
  167.             if (vs >= vs_top)
  168.                 FEerror("Too many return values.", 0);
  169.             if (ifuncall2(Stypep, *vs, MMcar(args)) == Cnil)
  170.                 FEwrong_type_argument(MMcar(args), *vs);
  171.         }
  172.         if (vs < vs_top)
  173.             FEerror("Too few return values.", 0);
  174.     } else {
  175.         if (ifuncall2(Stypep, vs_base[0], args) == Cnil)
  176.             FEwrong_type_argument(args, vs_base[0]);
  177.     }
  178. }
  179.  
  180. init_toplevel()
  181. {
  182.     make_special_form("DEFUN",Fdefun);
  183.     make_si_function("*MAKE-SPECIAL", siLAmake_special);
  184.     make_si_function("*MAKE-CONSTANT", siLAmake_constant);
  185.     make_special_form("EVAL-WHEN", Feval_when);
  186.     make_special_form("THE", Fthe);
  187.     Scompile = make_ordinary("COMPILE");
  188.     enter_mark_origin(&Scompile);
  189.     Sload = make_ordinary("LOAD");
  190.     enter_mark_origin(&Sload);
  191.     Seval = make_ordinary("EVAL");
  192.     enter_mark_origin(&Seval);
  193.     make_special_form("DECLARE",Fdeclare);
  194.     Sdeclare = make_ordinary("DECLARE");
  195.     enter_mark_origin(&Sdeclare);
  196.     Sprogn = make_ordinary("PROGN");
  197.     enter_mark_origin(&Sprogn);
  198.     Seval = make_ordinary("EVAL");
  199.     enter_mark_origin(&Seval);
  200.     make_special_form("LOCALLY",Flocally);
  201.  
  202.     siSvariable_documentation
  203.     = make_si_ordinary("VARIABLE-DOCUMENTATION");
  204.     siSfunction_documentation
  205.     = make_si_ordinary("FUNCTION-DOCUMENTATION");
  206.  
  207.     Swarn = make_ordinary("WARN");
  208.     enter_mark_origin(&Swarn);
  209.  
  210.     Svalues = make_ordinary("VALUES");
  211.     Stypep = make_ordinary("TYPEP");
  212.     enter_mark_origin(&Stypep);
  213. }
  214.